home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / test.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  29.5 KB  |  814 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require 'stdio)
  21. (require (in-vicinity (program-vicinity) "defs"))
  22.  
  23. (define diagout stdout)
  24.  
  25. ;;  call (SCANF root-handle [test-prev? #f] [verbose? #t])
  26.  
  27. (define (scanf han . args)
  28.   (define errors 0)
  29.   (define test-prev (if (> (length args) 0) (car args) #f))
  30.   (define verbose? (if (> (length args) 1) (cadr args) #f))
  31.   (fprintf diagout "FORWARD key scan\\n")
  32.   (let loop ((key #f) (prior #f) (init #t) (list ()))
  33.     (cond (verbose? (fprintf diagout "NEXT KEY IS ") (write key) (newline)))
  34.     (if (and test-prev (not init))
  35.     (let ((prev-key (bt:prev han key)))
  36.       (cond ((or (and prev-key prior (not (string=? prev-key prior)))
  37.              (and prev-key (not prior))
  38.              (and prior (not prev-key) (not (string=? prior ""))))
  39.          (set! errors (+ 1 errors))
  40.          (fprintf diagout "NEXT/PREV error: key= ")  (write prior) (newline)
  41.          (fprintf diagout "   next= ")  (write key)
  42.          (fprintf diagout " prev= ")  (write prev-key) (newline))
  43. ;;;        (else
  44. ;;;         (fprintf diagout "PREV of ") (write key)
  45. ;;;         (fprintf diagout " OK. \\n"))
  46.         )))
  47.     (if (or (and key (not (equal? "" key))) init)
  48.     (loop (bt:next han key) key #f (if key (cons key list) list))
  49.     (begin
  50.       (if test-prev (fprintf diagout "SCANF: %d next/prev errors found.\\n" errors))
  51.       (fprintf diagout "SCANF: %d items found.\\n" (length list))
  52.       list))))
  53.  
  54. (define (count-keys han)
  55.   (let loop ((key "") (ct 0) (init #t))
  56.     (if (or (and key (not (equal? "" key))) init)
  57.     (loop (bt:next han key) (+ ct 1) #f)
  58.     ct)))
  59.  
  60. (define (scanb han)
  61.   (fprintf diagout "REVERSE key scan\\n")
  62.   (let loop ((key #f) (init #t) (list ()))
  63.     (fprintf diagout "PREV KEY IS ")  (write key) (newline)
  64.     (if (or (and key (not (equal? "" key))) init)
  65.     (loop (bt:prev han key) #f (if key (cons key list) list))
  66.     (begin
  67.       (fprintf diagout "SCANB: %d items found.\\n" (length list))
  68.       list))))
  69.  
  70. (define (db-size han)
  71.   (+ (SEG-USED (HAN-SEG han)) 1))
  72.  
  73. (define current-bt #f)
  74. (define current-seg #f)
  75. (define add-key-num 0)
  76. (define add-str "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz")
  77.  
  78. ;; ADD! count [first-key add-key-num] [key-increment 1]  [value-string "abc...xyz"x2]
  79.  
  80. (define (add! n . args)
  81.   (let ((cur-key-num (if (> (length args) 0) (car args) add-key-num))
  82.     (incr (if (> (length args) 1) (cadr args) 1))
  83.     (addstr (if (> (length args) 2) (caddr args) add-str))
  84.     )
  85.     (do ((i 1 (+ i 1)))
  86.     ((> i n))
  87.       (let* ((key-str (number->string cur-key-num)))
  88.     (set! cur-key-num (+ incr cur-key-num))
  89. ;;;    (fprintf diagout "putting %s\\n" key-str)
  90.     (bt:put! current-bt key-str addstr)))
  91.     (set! add-key-num (max add-key-num cur-key-num))))
  92.  
  93. ;; REMOVE! count first-key [key-increment 1] [unused-arg]
  94.  
  95. (define (remove! n cur-key . args)
  96.   (let ((incr (if (> (length args) 0) (car args) 1))
  97.     (start-trace (if (> (length args) 1) (cadr args) #f)))
  98.     (do ((i 1 (+ i 1)))
  99.     ((> i n) i)
  100.       (let ((key-str (number->string cur-key)))
  101.     (set! cur-key (+ incr cur-key))
  102. ;;;    (fprintf diagout "deleting %s\\n" key-str)
  103.     (bt:rem! current-bt key-str)))))
  104.  
  105. ;; old test code, still useful!
  106.  
  107. (define (test0! b-han)
  108.   (bt:put! b-han "foo" "bar")
  109.   (bt:put! b-han "foz" "oof")
  110.   (bt:put! b-han "fonz" "zonf")
  111.   (bt:put! b-han "foo" "raboof")
  112.   (bt:put! b-han "food" "thought")
  113.   (scanf b-han)
  114.   (bt:rem! b-han "foo")
  115.   (bt:rem! b-han "fonz")
  116. ;  (tscan-full b-han)
  117.   (bt:put! b-han "foo" "foo=bar")
  118.   (bt:put! b-han "foz" "foz=oof")
  119.   (bt:put! b-han "fonz" "fonz=zonf")
  120.   (bt:put! b-han "foo" "foo=raboof")
  121.   (bt:put! b-han "food" "food=for thought")
  122.   (bt:put! b-han "very very very long key field" "very very very longer value field")
  123.   (scanf b-han))
  124.  
  125. ;;; THIS IS TEST CASE #1.
  126. ;;; It is used to test the addition of data elements with similar names
  127. ;;; to see if the repeat count routine is working correctly
  128. (define (test1)
  129.   (define a-han (create-bt current-seg IND-TYP 0))
  130.   (bt:put! a-han "cat" "6")
  131.   (bt:put! a-han "caddy" "4")
  132.   (bt:put! a-han "catalytic" "7")
  133.   (bt:put! a-han "cadalack" "3")
  134.   (bt:put! a-han "catastrophy" "10")
  135.   (bt:put! a-han "catastrophic" "9")
  136.   (bt:put! a-han "cad" "2")
  137.   (bt:put! a-han "cadjole" "5")
  138.   (bt:put! a-han "cataract" "8")
  139.   (bt:put! a-han "cacky" "1")
  140.   (bt:put! a-han "d" "12")
  141.   (scanf a-han)
  142.   (fprintf diagout "   TEST 1: nexting on block 'a' index 'cadz'\\n")
  143.   (let* ((ans-str (bt:next a-han "cadz")))
  144.     (fprintf diagout "%s\\n" ans-str))
  145.   (fprintf diagout "   TEST 1: removing 'd' from 'a'\\n")
  146.   (bt:rem! a-han "d")
  147.   (scanf a-han)
  148.   (fprintf diagout "   TEST 1: removing 'cad' from 'a'\\n")
  149.   (bt:rem! a-han "cad")
  150.   (scanf a-han)
  151.   (close-bt! a-han))
  152.  
  153. ;;; THIS IS TEST #2 FOR BLOCK SPLITTING STUFF
  154. ;;; this test fills a block completely then adds a new data element and value
  155. ;;; to the block to make it split
  156. (define (test2)
  157.   (define b-han (create-bt current-seg IND-TYP 0))
  158.   (bt:put! b-han "foo" "bar")
  159.   (bt:put! b-han "foz" "oof")
  160.   (bt:put! b-han "fonz" "zonf")
  161.   (bt:put! b-han "foo" "raboof")
  162.   (bt:put! b-han "food" "thought")
  163.   (scanf b-han)
  164.   (bt:rem! b-han "foo")
  165.   (bt:rem! b-han "fonz")
  166.   (scanf b-han)
  167.   (fprintf diagout "   TEST 2: creating a full block named 'b'\\n")
  168.   (bt:put! b-han "foo" "1234567")
  169.   (bt:put! b-han "foz" "12345678901")
  170.   (bt:put! b-han "fonz" "123456789")
  171.   (bt:put! b-han "foo" "1234567890")
  172.   (bt:put! b-han "food" "1234567890123456")
  173.   (bt:put! b-han "test" "123456789012345678901234")
  174.   (fprintf diagout "   TEST 2: doing a PUT to fill the block\\n")
  175.   (bt:put! b-han "a" "12345678")
  176.   (scanf b-han)
  177.   (close-bt! b-han))
  178.  
  179. ;;; THIS IS TEST #3 FOR BLOCK SPLITTING STUFF
  180. ;;; this test fills a block , then it tries to make the block split by making
  181. ;;; the first data element 1 char bigger by replacement
  182. (define (test3)
  183.   (define c-han (create-bt current-seg IND-TYP 0))
  184.   (bt:put! c-han "foo" "1234567")
  185.   (bt:put! c-han "foz" "12345678901")
  186.   (bt:put! c-han "fonz" "123456789")
  187.   (bt:put! c-han "foo" "1234567890")
  188.   (bt:put! c-han "food" "1234567890123456")
  189.   (bt:put! c-han "test" "123456789012345678901234")
  190.   (bt:put! c-han "a" "12345678")
  191.   (scanf c-han)
  192.   (fprintf diagout "   TEST 3: split block by increasing first element by one char with PUT\\n")
  193.   (bt:put! c-han "a" "123456789")
  194.   (scanf c-han)
  195.   (close-bt! c-han))
  196.  
  197. ;;; THIS IS TEST #4 FOR BLOCK SPLITTING STUFF
  198. ;;; this test fills a block , then it tries to make the block split by making
  199. ;;; a middle data element 1 char bigger by replacement
  200. (define (test4)
  201.   (define d-han (create-bt current-seg IND-TYP 0))
  202.   (bt:put! d-han "foo" "1234567")
  203.   (bt:put! d-han "foz" "12345678901")
  204.   (bt:put! d-han "fonz" "123456789")
  205.   (bt:put! d-han "foo" "1234567890")
  206.   (bt:put! d-han "food" "1234567890123456")
  207.   (bt:put! d-han "test" "123456789012345678901234")
  208.   (bt:put! d-han "a" "12345678")
  209.   (scanf d-han)
  210.   (fprintf diagout "   TEST 4: split block by incresing value of a middle element by one with PUT\\n")
  211.   (bt:put! d-han "foz" "123456789012")
  212.   (scanf d-han)
  213.   (close-bt! d-han))
  214.  
  215. ;;; THIS IS TEST #5 FOR BLOCK SPLITTING STUFF
  216. ;;; this test fills a block , then it tries to make the block split by making
  217. ;;; the last data element 1 char bigger by replacement
  218. (define (test5)
  219.   (define e-han (create-bt current-seg IND-TYP 0))
  220.   (bt:put! e-han "foo" "1234567")
  221.   (bt:put! e-han "foz" "12345678901")
  222.   (bt:put! e-han "fonz" "123456789")
  223.   (bt:put! e-han "foo" "1234567890")
  224.   (bt:put! e-han "food" "1234567890123456")
  225.   (bt:put! e-han "test" "123456789012345678901234")
  226.   (bt:put! e-han "a" "12345678")
  227.   (scanf e-han)
  228.   (fprintf diagout "   TEST 5: split block by incresing value of the last data element by one with PUT\\n")
  229.   (bt:put! e-han "test" "12345678901234567890123456")
  230.   (scanf e-han)
  231.   (close-bt! e-han))
  232.  
  233. ;;; THIS IS TEST #6 FOR BLOCK SPLITTING STUFF
  234. ;;; this test fills a block , then it deletes the first element. It then
  235. ;;; tries to make the block split by reentering the first data element
  236. ;;; with 1 more char than the original
  237. (define (test6)
  238.   (define f-han (create-bt current-seg IND-TYP 0))
  239.   (bt:put! f-han "foo" "1234567")
  240.   (bt:put! f-han "foz" "12345678901")
  241.   (bt:put! f-han "fonz" "123456789")
  242.   (bt:put! f-han "foo" "1234567890")
  243.   (bt:put! f-han "food" "1234567890123456")
  244.   (bt:put! f-han "test" "123456789012345678901234")
  245.   (bt:put! f-han "a" "12345678")
  246.   (scanf f-han)
  247.   (fprintf diagout "   TEST 6: split block by deleting the first data element with REM\\n")
  248.   (fprintf diagout "   TEST 6: then reentering the first data element with 1 more char\\n")
  249.   (bt:rem! f-han "a")
  250.   (fprintf diagout "   TEST 6: doing a PUT\\n")
  251.   (bt:put! f-han "a" "123456789")
  252.   (scanf f-han)
  253.   (close-bt! f-han))
  254.  
  255. ;;; THIS IS TEST #7 FOR BLOCK SPLITTING STUFF
  256. ;;; this test fills a block , then it deletes a middle element. It then
  257. ;;; tries to make the block split by reentering a middle element with 1
  258. ;;; more char than the original
  259. (define (test7)
  260.   (define g-han (create-bt current-seg IND-TYP 0))
  261.   (bt:put! g-han "foo" "1234567")
  262.   (bt:put! g-han "foz" "12345678901")
  263.   (bt:put! g-han "fonz" "123456789")
  264.   (bt:put! g-han "foo" "1234567890")
  265.   (bt:put! g-han "food" "1234567890123456")
  266.   (bt:put! g-han "test" "123456789012345678901234")
  267.   (bt:put! g-han "a" "12345678")
  268.   (scanf g-han)
  269.   (fprintf diagout "   TEST 7: split block by deleting a middle data element\\n")
  270.   (fprintf diagout "   TEST 7: then reentering a middle data element with 1 more char\\n")
  271.   (fprintf diagout "   TEST 7: than the original value.\\n")
  272.   (bt:rem! g-han "foo")
  273.   (fprintf diagout "   TEST 7: doing a PUT\\n")
  274.   (bt:put! g-han "foo" "12345678901")
  275.   (scanf g-han)
  276.   (close-bt! g-han))
  277.  
  278. ;;; THIS IS TEST #8 FOR BLOCK SPLITTING STUFF
  279. ;;; this test fills a block , then it deletes the last element. It then
  280. ;;; tries to make the block split by reentering the last element with 1
  281. ;;; more char than the original
  282. (define (test8)
  283.   (define h-han (create-bt current-seg IND-TYP 0))
  284.   (bt:put! h-han "foo" "1234567")
  285.   (bt:put! h-han "foz" "12345678901")
  286.   (bt:put! h-han "fonz" "123456789")
  287.   (bt:put! h-han "foo" "1234567890")
  288.   (bt:put! h-han "food" "1234567890123456")
  289.   (bt:put! h-han "test" "123456789012345678901234")
  290.   (bt:put! h-han "a" "12345678")
  291.   (scanf h-han)
  292.   (fprintf diagout "   TEST 8: split block by deleting the last data element\\n")
  293.   (fprintf diagout "   TEST 8: then reentering the last data element with 1 more char\\n")
  294.   (fprintf diagout "   TEST 8: than the original value.  Block name is 'h'\\n")
  295.   (bt:rem! h-han "test")
  296.   (fprintf diagout "   TEST 8: doing a PUT\\n")
  297.   (bt:put! h-han "test" "12345678901234567890123456")
  298.   (scanf h-han)
  299.   (close-bt! h-han))
  300.  
  301. ;;; THIS IS TEST #9 FOR BLOCK SPLITTING STUFF
  302. ;;; this test fills a block completely then adds a new data element and value
  303. ;;; to the block to make it split
  304. (define (test9)
  305.   (define i-han (create-bt current-seg IND-TYP 0))
  306.   (bt:put! i-han "foz" "12345678901")
  307.   (bt:put! i-han "fonz" "123456789")
  308.   (bt:put! i-han "foo" "1234567890")
  309.   (bt:put! i-han "food" "1234567890123456")
  310.   (bt:put! i-han "test" "123456789012345678901234")
  311.   (bt:put! i-han "a" "12345678")
  312.   (fprintf diagout "   TEST 9: The block 'i' is full. Now we are adding a new index to the begining\\n")
  313.   (fprintf diagout "   TEST 9: of the block with a value that should make the block split\\n")
  314.   (bt:put! i-han "1" "123456789")
  315.   (scanf i-han)
  316.   (close-bt! i-han))
  317.  
  318. ;;; THIS IS TEST #10 FOR BLOCK SPLITTING STUFF
  319. ;;; this test fills a block completely then adds a new data element and value
  320. ;;; to the block to make it split
  321. (define (test10)
  322.   (define j-han (create-bt current-seg IND-TYP 0))
  323.   (bt:put! j-han "foz" "12345678901")
  324.   (bt:put! j-han "fonz" "123456789")
  325.   (bt:put! j-han "foo" "1234567890")
  326.   (bt:put! j-han "food" "1234567890123456")
  327.   (bt:put! j-han "test" "123456789012345678901234")
  328.   (bt:put! j-han "a" "12345678")
  329.   (fprintf diagout "   TEST 10: The block 'j' is full. Now we are adding a new index to the middle\\n")
  330.   (fprintf diagout "   TEST 10: of the block with a value that should make the block split\\n")
  331.   (bt:put! j-han "fooa" "123456789")
  332.   (scanf j-han)
  333.   (close-bt! j-han))
  334.  
  335. ;;; THIS IS TEST #11 FOR BLOCK SPLITTING STUFF
  336. ;;; this test fills a block completely then adds a new data element and value
  337. ;;; to the block to make it split
  338. (define (test11)
  339.   (define k-han (create-bt current-seg IND-TYP 0))
  340.   (bt:put! k-han "foz" "12345678901")
  341.   (bt:put! k-han "fonz" "123456789")
  342.   (bt:put! k-han "foo" "1234567890")
  343.   (bt:put! k-han "food" "1234567890123456")
  344.   (bt:put! k-han "test" "123456789012345678901234")
  345.   (bt:put! k-han "a" "12345678")
  346.   (fprintf diagout "   TEST 11: The block 'k' is full. Now we are adding a new index to the end\\n")
  347.   (fprintf diagout "   TEST 11: of the block with a value that should make the block split\\n")
  348.   (bt:put! k-han "zzz" "123456789")
  349.   (scanf k-han)
  350.   (close-bt! k-han))
  351.  
  352. ;;; THIS IS TEST #12 FOR BLOCK SPLITTING STUFF
  353. ;;; this test fills a block completely then adds a new data element and value
  354. ;;; to the block to make it split
  355. (define (test12)
  356.   (define k-han (create-bt current-seg IND-TYP 0))
  357.   (bt:put! k-han "132" "12345678901")
  358.   (bt:put! k-han "1233" "1234567890")
  359.   (bt:put! k-han "26" "1234567890123456")
  360.   (bt:put! k-han "275" "123456789012345678901234")
  361.   (bt:put! k-han "84" "12345678")
  362.   (fprintf diagout "   TEST 12: The block 'k' is full. Now we are adding a new index pastp after b-pos\\n")
  363.   (fprintf diagout "   TEST 12: of the block with a value that should make the block split\\n")
  364.   (bt:put! k-han "82" "123456789")
  365.   (scanf k-han)
  366.   (close-bt! k-han))
  367.  
  368. (define (test13)
  369.   (define k-han (create-bt current-seg IND-TYP 0))
  370.   (bt:put! k-han "0132" "12345678901")
  371.   (bt:put! k-han "01233" "1234567890")
  372.   (bt:put! k-han "026" "1234567890123456")
  373.   (bt:put! k-han "0275" "123456789012345678901234")
  374.   (bt:put! k-han "084" "12345678")
  375.   (fprintf diagout "   TEST 13: The block 'k' is full. Now we are adding a new index pastp after b-pos\\n")
  376.   (fprintf diagout "   TEST 13: of the block with a value that should make the block split\\n")
  377.   (bt:put! k-han "082" "123456789")
  378.   (scanf k-han)
  379.   (close-bt! k-han))
  380.  
  381. (define (test14)
  382.   (define k-han (create-bt current-seg IND-TYP 0))
  383.   (bt:put! k-han "0132" "12345678901")
  384.   (bt:put! k-han "01233" "1234567890")
  385.   (bt:put! k-han "026" "1234567890123456")
  386.   (bt:put! k-han "04" "123456789012345678901234")
  387.   (bt:put! k-han "041" "1234567890")
  388.   (fprintf diagout "   TEST 14: The block 'k' is full. Now we are adding a new index pastp after b-pos\\n")
  389.   (fprintf diagout "   TEST 14: of the block with a value that should make the block split\\n")
  390.   (tscan-blk (han-id k-han))
  391.   (bt:put! k-han "040" "123456789")
  392.   (tscan-blk (han-id k-han))
  393.   (close-bt! k-han))
  394.  
  395. (define (test)
  396.   (test1)
  397.   (test2)
  398.   (test3)
  399.   (test4)
  400.   (test5)
  401.   (test6)
  402.   (test7)
  403.   (test8)
  404.   (test9)
  405.   (test10)
  406.   (test11)
  407.   (test12)
  408.   (test13))
  409.  
  410. (define (main)
  411.   (fprintf diagout "make-seg\\n")
  412.   (make-seg 9 "z" 128)
  413.   (fprintf diagout "open-seg\\n")
  414.   (set! current-seg (open-seg 9 "z" 2))
  415.   (fprintf diagout "create-bt\\n")
  416.   (set! current-bt (create-bt current-seg IND-TYP 0))
  417.   (fprintf diagout "test0!\\n")
  418.   (test0! current-bt)
  419.   (fprintf diagout "test!\\n")
  420.   (test)
  421.   (fprintf diagout "add! 10\\n")
  422.   (add! 10)
  423. ;  (check-access!)
  424.   (close-seg current-seg #f)
  425.   (set! current-seg (open-seg 9 "z" 2))
  426.   (scanf current-bt)
  427.   (close-seg current-seg #f)
  428.   0)
  429.  
  430. (define (show-blk seg blk)
  431.   (check-access!)
  432.   (let ((ent (get-ent seg blk ACCREAD)))
  433.     (release-ent! ent ACCREAD)
  434.     (ENT-BLK ent)))
  435.  
  436. (define (rmain . args)
  437.   (fprintf diagout "make-seg\\n")
  438.   (make-seg 9 "z" 128)
  439.   (fprintf diagout "open-seg\\n")
  440.   (set! current-seg (open-seg 9 "z" 2))
  441.   (fprintf diagout "create-bt\\n")
  442.   (set! current-bt (create-db current-seg IND-TYP "test"))
  443.   (fprintf diagout "tscan \\n")
  444.   (tscan)
  445.   (fprintf diagout "test0!\\n")
  446.   (test0! current-bt)
  447.   ;  (fprintf diagout "test!\\n")
  448.   ;  (test)
  449.   ; test for INSERT bug!!
  450.   (tscan)
  451.   (cond ((> (length args) 0)
  452.      (fprintf diagout "TESTING for INSERT BUG\\n")
  453.      (bt:put! current-bt "xxx2" "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")
  454.      (tscan)
  455.      (bt:put! current-bt "xxx3" "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")
  456.      (tscan)
  457.      (bt:put! current-bt "xxx1" "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")
  458.      (tscan)
  459.      (bt:put! current-bt "xxx0" "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")
  460.      (tscan)
  461.     ))
  462.   (if #f (begin
  463.        (fprintf diagout "add! 10\\n")
  464.        (add! 10)
  465.        ;  (check-access!)
  466.        ))
  467.   (close-seg current-seg #f)
  468.   (set! current-seg (open-seg 9 "z" 2))
  469.   (set! current-bt (open-db current-seg "test"))
  470.   (scanf current-bt)
  471.   (close-seg current-seg #f)
  472.   (set! current-seg #f)
  473.   0)
  474.  
  475. ;; Aubrey -- I expect this routine to leave the file OPEN --roy.
  476. (define (qmain)
  477.   (fprintf diagout "open-seg\\n")
  478.   (set! current-seg (open-seg 9 "z" 2))    ;read only
  479.   (set! current-bt (let ((han (open-db current-seg "test")))
  480.              (if (not han)
  481.              (begin (fprintf diagout "`test' created\\n")
  482.                 (create-db 9 IND-TYP "test"))
  483.              han)))
  484.   (if current-bt
  485.       (scanf current-bt)
  486.       (fprintf diagout "db `test' not found\\n")))
  487.  
  488. ;;;; The rest of this will run only in scheme.
  489.  
  490. ;; call (TSCAN-FULL root-seg root-blk
  491. ;;              [#of-sublevels 1] [#of-blks-to-chain-fwd 99] [mode 2]
  492. ;;  (plus internal args:)
  493. ;;              [indent-string ''] [split-key #f] [skey-len 0]
  494. ;;              [parent -1] [expected-level -1]
  495. ;; MODE: 0=print errors only; 1=errors+warnings; 2=1+block contents
  496. ;;
  497. ;; call (TSTATS) for just error check and tree stats
  498. ;;
  499. ;; BUG: subblocks missing ptr from parent wont show up! (what a pain)
  500. ;; BUG: especially on the right fringe of the tree!
  501. ;; BUG: doesnt yet recurse through directories
  502. ;;
  503. ;; Instrumented to test five things:
  504. ;;  1. that keys are in order at each level;
  505. ;;  2. that keys are carried over correctly between levels;
  506. ;;  3. to flag blocks missing their parent pointer (not an error, really)
  507. ;;  4+5. check consistency of ROOT PTR and TREE TYPE
  508. ;;
  509. ;; Instrumented to collect statistics:
  510. ;;  A. Blocks used (per level; overall)
  511. ;;  B. Branching factor (per level; overall)
  512. ;;  C. Block utilization (per level; overall)
  513. ;;
  514. (define (tscan-full seg blk-num . args)
  515.   (let* ((nlevels (if (> (length args) 0) (car args) 1))
  516.      (nblks (if (> (length args) 1) (cadr args) 99))
  517.      (mode (if (> (length args) 2) (caddr args) 2))
  518.      )
  519.     (set! root-blk 0)
  520.     (set! root-type #f)
  521.     (set! tscan-errs 0)
  522.     (set! tscan-warns 0)
  523.     (do ((i 0 (+ i 1)))            ; init things for checks
  524.     ((>= i 20))
  525.       (vector-set! tscan-keycts i 0)
  526.       (vector-set! tscan-blkcts i 0)
  527.       (vector-set! tscan-bytects i 0)
  528.       (vector-set! tscan-lengths i -1)
  529.       (vector-set! tscan-prevs i -1)
  530.       (vector-set! tscan-expnexts i -1))
  531.     (tscan-internal seg blk-num nlevels nblks mode "" "" 0 -1 -1)
  532.     (fprintf diagout "\\n%d ERRORS, %d WARNINGS.\\n\\n"
  533.          tscan-errs tscan-warns)
  534.     (fprintf diagout "TREE SHAPE STATISTICS\\n")
  535.     (fprintf diagout "LEVEL  BLOCKS    KEYS BRANCHING  BYTES  %%USED \\n")
  536.     (fprintf diagout "                 /BLK FACTOR     /BLK   /BLK  \\n")
  537.     (let ((tblks 0)
  538.       (tkeys 0)
  539.       (tbytes 0)
  540.       (bpb (- (SEG-BSIZ seg) BLK-DATA-START)))
  541.       (do ((i 0 (+ i 1)))
  542.       ((>= i 20))
  543.     (let ((blks (vector-ref tscan-blkcts i))
  544.           (keys (vector-ref tscan-keycts i))
  545.           (bytes (vector-ref tscan-bytects i)))
  546.       (set! tblks (+ tblks blks))
  547.       (set! tkeys (+ tkeys keys))
  548.       (set! tbytes (+ bytes tbytes))
  549.       (cond ((> blks 0)
  550.          (fprintf diagout "%5d %7d %7d %8d%% %6d %6d%%\\n"
  551.               i blks keys (quotient (* keys 100) blks)
  552.               (quotient (* (quotient bytes blks) bpb) 100)
  553.               (quotient bytes blks))))))
  554.       (fprintf diagout "TOTAL %7d %7d %8d%% %6d %6d%%\\n"
  555.            tblks tkeys (quotient (* tkeys 100) tblks)
  556.               (quotient (* (quotient tbytes tblks) bpb) 100)
  557.               (quotient tbytes tblks))
  558.       (fprintf diagout "\\n BLKS-USED=%d BLK-SIZE=%d FILE-SIZE=%d\\n"
  559.            (+ (SEG-USED seg) 1) (SEG-BSIZ seg)
  560.            (* (+ (SEG-USED seg) 1) (SEG-BSIZ seg)))
  561.       )))
  562.  
  563. (define (tscan)
  564.   (check-access!)
  565.   (tscan-blk (HAN-ID current-bt)))
  566.  
  567. (define (tstats)
  568.   (check-access!)
  569.   (tscan-full current-seg (HAN-ID current-bt) 99 99 1))
  570.  
  571. (define (tscan-blk blk-num)
  572.   (check-access!)
  573.   (tscan-full current-seg blk-num))
  574.  
  575. (define tmp-str2 (make-string 256))
  576. (define tmp-str3 (make-string 256))
  577. (define tscan-errs 0)
  578. (define tscan-warns 0)
  579. (define root-blk 0)
  580. (define root-type 0)
  581. (define tscan-keys (make-vector 20))
  582. (define tscan-lengths (make-vector 20))
  583. (define tscan-prevs (make-vector 20))
  584. (define tscan-expnexts (make-vector 20))
  585. (define tscan-keycts (make-vector 20))
  586. (define tscan-blkcts (make-vector 20))
  587. (define tscan-bytects (make-vector 20))
  588.  
  589. (do ((i 0 (+ i 1)))
  590.     ((>= i 20))
  591.   (vector-set! tscan-keys i (make-string 256)))
  592.  
  593. (define (tscan-internal seg blk-num nlevels nblks mode
  594.             indent skey skey-len parent explevel)
  595.   (let* ((ent (get-ent seg blk-num ACCREAD))
  596.      (blk (if ent (ENT-BLK ent) #f))
  597.      (blklev (if ent (- (BLK-LEVEL blk) LEAF)))
  598.      (tlen (recon-this-key-debug blk (split-key-pos blk)
  599.                      tmp-str2 0 256))
  600.      (lidx (- (BLK-LEVEL blk) LEAF))
  601.      (last-key-str (vector-ref tscan-keys lidx))
  602.      (last-len (vector-ref tscan-lengths lidx)))
  603.     (cond
  604.      (ent
  605.       (cond ((= parent -1)
  606.          (set! root-blk (BLK-TOP-ID blk))
  607.          (set! root-type (BLK-TYP blk))))
  608.       (vector-set! tscan-blkcts blklev
  609.            (+ (vector-ref tscan-blkcts blklev) 1))
  610.       (if (> mode 1)
  611.       (fprintf diagout
  612.            "%s scanning blk %d:%ld top= %d next= %d len= %d room= %d level= %d type= %c end= %d\\n"
  613.            indent (ENT-SEG ent)(BLK-ID blk)(BLK-TOP-ID blk)(BLK-NXT-ID blk)
  614.            (- (BLK-END blk) BLK-DATA-START)
  615.            (- (SEG-BSIZ current-seg) (BLK-END blk))
  616.            (BLK-LEVEL blk)(BLK-TYP blk)(BLK-END blk)))
  617.                     ; test 4+5: root and tree type
  618.       (cond ((not (= root-blk (BLK-TOP-ID blk)))
  619.          (set! tscan-errs (+ tscan-errs 1))
  620.          (fprintf diagout "ERROR: Block %d:%ld in tree %d thinks its in tree %d\\n"
  621.               (ENT-SEG ent) (ENT-ID ent) root-blk (BLK-TOP-ID blk))))
  622.       (cond ((not (char=?  root-type (BLK-TYP blk)))
  623.          (set! tscan-errs (+ tscan-errs 1))
  624.          (fprintf diagout "ERROR: Block %d:%ld in tree type %c thinks its of type %c\\n"
  625.               (ENT-SEG ent) (ENT-ID ent)  root-type (BLK-TYP blk))))
  626.                     ; test 2:split key match
  627.       (cond ((and (> parent -1) (not (str-eql? tmp-str2 0 tlen skey 0 skey-len)))
  628.          (set! tscan-errs (+ tscan-errs 1))
  629.          (let ((error? (str-gtr? tmp-str2 0 tlen skey 0 skey-len)))
  630.            (cond (error? (fprintf diagout "ERROR split key mismatch:\\n")
  631.                  (set! tscan-errs (+ tscan-errs 1)))
  632.              (else (set! tscan-warns (+ tscan-warns 1))
  633.                (if (> mode 0)
  634.                    (fprintf diagout "WARNING split key mismatch:\\n"))))
  635.            (cond ((or error? (> mode 0))
  636.               (fprintf diagout "  --Block %d:%ld has key %.*s (%d)\\n"
  637.                    seg blk-num tlen tmp-str2 tlen)
  638.               (fprintf diagout "  --while parent %d:%ld thinks key is %.*s (%d)\\n"
  639.                    seg parent skey-len skey skey-len))))))
  640.                     ; test 3: missing parent ptrs
  641.       (let ((expnext (vector-ref tscan-expnexts lidx))
  642.         (bt:prev (vector-ref tscan-prevs lidx)))
  643.     (cond ((and (> expnext -1) (not (= expnext blk-num)))
  644.            (set! warns-errs (+ tscan-warns 1))
  645.            (cond ((> mode 0)
  646.               (fprintf diagout "WARNING: parent ptr missing for blk %d:%ld.\\n"
  647.                    seg expnext)
  648.               (fprintf diagout " --current blk=%d, parent=%d, last=%d, exp=%d.\\n"
  649.                    blk-num parent prev expnext)
  650.               )))))
  651.       (cond ((and (> explevel -1) (not (= explevel (BLK-LEVEL blk))))
  652.          (set! tscan-errs (+ tscan-errs 1))
  653.          (fprintf diagout "ERROR: blk %d:%ld at level %d is child of blk %d:%ld at level %d\\n"
  654.            seg blk-num (blk-level blk) seg parent (+ 1 explevel))))
  655.       (vector-set! tscan-expnexts lidx (BLK-NXT-ID blk))
  656.       (vector-set! tscan-prevs lidx blk-num)
  657.                     ; scan block contents
  658.       (do ((first-key #t #f)
  659.        (b-pos BLK-DATA-START)
  660.        (pos 0) (count 0 (+ count 1))
  661.        (key-str tmp-str) (k-len 0))
  662.       ((>= b-pos (BLK-END blk)))
  663.     (set! pos b-pos)
  664.     (set! k-len (recon-this-key-debug blk pos key-str 0 256))
  665.     (set! b-pos (next-field blk (+ 1 b-pos)))
  666.                     ; test #1: key order
  667.     (cond ((and (> last-len -1)
  668.             (if first-key
  669.             (str-gtr? last-key-str 0 last-len key-str 0 k-len)
  670.             (not (str-gtr? key-str 0 k-len last-key-str 0 last-len))))
  671.            (set! tscan-errs (+ tscan-errs 1))
  672.            (fprintf diagout "KEY ORDER ERROR at blk %d:%ld pos %d\\n"
  673.             seg blk-num pos)
  674.            (fprintf diagout " --key=%.*s last key=%.*s.\\n"
  675.             k-len key-str last-len last-key-str)))
  676.     (substring-move! key-str 0 k-len last-key-str 0)
  677.     (vector-set! tscan-lengths lidx k-len)
  678.     (set! last-len k-len)
  679.                     ; print block contents
  680.     (cond ((< b-pos (BLK-END blk))
  681.            (cond ((LEAF? blk)
  682.               (if (> mode 1)
  683.               (fprintf diagout  "%s at %d key= %s value= %s\\n"
  684.                    indent pos
  685.                    (substring key-str 0 k-len)
  686.                    (substring blk (+ 1 b-pos)
  687.                       (+ 1 b-pos (field-len blk b-pos))))))
  688.              (else
  689.               (if (> mode 1)
  690.               (fprintf diagout "%s at %d key= %s ptr= %d\\n"
  691.                    indent pos (substring key-str 0 k-len)
  692.                    (str2long blk (+ 1 b-pos))))
  693.               (if (> nlevels 0)
  694.               (tscan-internal seg (str2long blk (+ 1 b-pos))
  695.                       (- nlevels 1) 0 mode
  696.                       (string-append indent "   ")
  697.                       key-str k-len blk-num
  698.                       (- (BLK-LEVEL blk) 1)))))
  699.            (set! b-pos (next-field blk b-pos)))
  700.           (else     
  701.            (vector-set! tscan-keycts blklev
  702.                 (+ (vector-ref tscan-keycts blklev) count))
  703.            (vector-set! tscan-bytects blklev
  704.                 (+ (vector-ref tscan-bytects blklev)
  705.                    (quotient (* 100 (- (BLK-END blk) BLK-DATA-START))
  706.                      (- (SEG-BSIZ seg) BLK-DATA-START))))
  707.            (if (> mode 1)
  708.            (fprintf diagout "%s at %d split= %s\\n"
  709.             indent pos (substring key-str 0 k-len))))))
  710.       (let ((nxt (BLK-NXT-ID blk)))
  711.     (release-ent! ent ACCREAD)
  712.     (cond ((and (not (zero? nxt))
  713.             (> nblks 0))
  714.            (newline)
  715.            (tscan-internal seg nxt nlevels (- nblks 1) mode indent "" 0 parent explevel))
  716.           (else #f))))
  717.      (else
  718.       (set! tscan-errs (+ tscan-errs 1))
  719.       (fprintf diagout "%s ERROR: can't access blk %d:%ld. \\n"
  720.            indent seg blk-num)))))
  721.  
  722. (define (str-eql? a-str a-pos a-len b-str b-pos b-len)
  723.   (and (= a-len b-len)
  724.        (let loop ((i 0) (ap a-pos) (bp b-pos))
  725.      (cond ((>= i a-len) #t)
  726.            ((not (char=? (string-ref a-str ap) (string-ref b-str bp))) #f)
  727.            (else (loop (+ i 1) (+ ap 1) (+ bp 1)))))))
  728.  
  729.  
  730. ;; temp hack in case rean RECON is traced...
  731.  
  732. (define (recon-this-key-debug blk pos key-str k-pos k-len)
  733.   (do ((b-pos BLK-DATA-START)
  734.        (k-size 0))
  735.       ((> b-pos pos) (substring  key-str k-pos (+ k-pos k-size)) k-size)
  736.     (substring-move! blk (+ b-pos 2)
  737.              (+ b-pos 2 (field-len blk (+ 1 b-pos)))
  738.              key-str
  739.              (+ k-pos (field-len blk b-pos)))
  740.     (set! k-size (+ (field-len blk b-pos) (field-len blk (+ 1 b-pos))))
  741.     (if (>= k-size k-len) not-enough-room)
  742.     (set! b-pos (next-field blk (+ 1 b-pos)))
  743.     (if (< b-pos (blk-end blk)) (set! b-pos (next-field blk b-pos)))))
  744.  
  745. ;; (close-seg 9 #f) (load "all") (load "main") (rmain)(qmain)(cstats)(add! 50) (add! 300 "a b c d e f g h i j")  (Cstats)
  746.  
  747. (define (prof)
  748.   (define (start) 0)
  749.   (make-seg 9 "z" 2048)
  750.   (set! current-seg (open-seg 9 "z" 2))
  751.   (set! current-bt (create-db 9 IND-TYP "test"))
  752.   (clear-stats)
  753.   (set! start (get-internal-run-time))
  754.   (add! 100 0 1)
  755.   (add! 100 990 -10)
  756.   (add! 100 1000 100)
  757.   (display "Adds took ")
  758.   (display (quotient (* 1000 (- (get-internal-run-time) start)) internal-time-units-per-second))
  759.   (display " Msec")
  760.   (newline)
  761.   (cstats)
  762.  
  763.   (set! start (get-internal-run-time))
  764.   (scanf current-bt)
  765.   (display "forward scan took ")
  766.   (display (quotient (* 1000 (- (get-internal-run-time) start)) internal-time-units-per-second))
  767.   (display " Msec")
  768.   (newline)
  769.   (cstats)
  770.  
  771.   (set! start (get-internal-run-time))
  772.   (scanb current-bt)
  773.   (display "backward scan took ")
  774.   (display (quotient (* 1000 (- (get-internal-run-time) start)) internal-time-units-per-second))
  775.   (display " Msec")
  776.   (newline)
  777.   (cstats)
  778.  
  779.   (set! start (get-internal-run-time))
  780.   (remove! 100 0 1)
  781.   (remove! 100 990 -10)
  782.   (remove! 100 1000 100)
  783.   (display "Removes took ")
  784.   (display (quotient (* 1000 (- (get-internal-run-time) start)) internal-time-units-per-second))
  785.   (display " Msec")
  786.   (newline)
  787.   (cstats)
  788.  
  789.   (close-seg current-seg #f)
  790.   0)
  791.  
  792. (define (radd! span)
  793.   (require 'random)
  794.   (fprintf diagout "adding %d records with random keys\\n" span)
  795.   (do ((i add-key-num (+ 1 i)) (r (random (* 10 span)) (random (* 10 span))))
  796.       ((>= i (+ add-key-num span)))
  797.     (bt:put! current-bt (number->string r) (string-append (number->string i) "number written in random test")))
  798.   (set! add-key-num (+ add-key-num span)))
  799.  
  800. (define (radd! span key)
  801.   (require 'random)
  802.   (fprintf diagout "adding %d records with random keys\\n" span)
  803.   (do ((i add-key-num (+ 1 i)) (r (random (* 10 span)) (random (* 10 span))))
  804.       ((>= i (+ add-key-num span)))
  805.     (bt:put! current-bt (number->string r) key))
  806.   (set! add-key-num (+ add-key-num span)))
  807.  
  808. (define (check)
  809.   (system "check z"))
  810.  
  811. (define (view)
  812.   (system "view z"))
  813.  
  814.